SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00006 1 05-25-9408:17ALL WIM VAN VOLLENHOVEN LONG String Arrays SWAG9405 33 ^& π{πGV> Hi Wim,πHi Greg...ππGV> It wouldn't be difficult to write Pos, Copy, Assign, etc., whichπGV> operate on an ARRAY OF CHAR -- using the ASCIIZ scheme, or a lengthπGV> WORD (rather than length byte) at array elements [0] and [1].ππAs you can see in a other message has wim van der vegt written aπcomplete unit with these functions :-)ππit was a 'little' bit reprogramming to implement these new functions butπit was worth while <g>ππGV> Greg_πThanx for your answer, Wimππhere is the code :π}ππUnit MyStr;ππINTERFACEπππConstπ maxlength = 512;π nul = #00;π cr = #13;π lf = #10;π sp = #32;ππTypeπ indexrange = 0..maxlength;π stringtype = Recordπ length : indexrange;π chars : Array[1..maxlength] Of char;π End;πππFunction Long_Length(s : stringtype) : indexrange;πProcedure Long_Readln(Var f : text;var l : stringtype);πProcedure Long_Write(Var f : text;var l : stringtype);πProcedure Long_Writeln(Var f : text;var l : stringtype);πProcedure Long_Copy(s : stringtype;Var d : stringtype; index,count : indexrange);πProcedure Long_Concat(Var d : stringtype;s : String);ππIMPLEMENTATIONπ{---------------------------------------------------------}π{ Author : Ir. G.W. van der Vegt }π{ Project : Longer strings }π{ Source : Pascal + Data Structures by Dale/Lilly }π{ ISBN 0-669-07239-7 }π{---------------------------------------------------------}π{ Modified to give less errors and act more like TP's }π{ functions. Can be made more efficient by using move, }π{ moving the inc of length's out of the for loops and }π{ not using the Length function to calc the length but }π{ use the field in the record. etc. }π{---------------------------------------------------------}π{ Because Turbo Pascal's Functions won't return records }π{ most of the Turbo Pascal String functions equivalents }π{ can only be procedures. }π{---------------------------------------------------------}π{ The code hasn't been tested well yet so expect some }π{ errors to be in it. All I have detected are fixed. }π{ For testing set maxlength at 20 or 30. }π{---------------------------------------------------------}πππFunction Long_Length(s : stringtype) : indexrange;ππBeginπ Long_Length:=s.length;πEnd;ππProcedure Long_Readln(Var f : text;var l : stringtype);ππBeginπ l.length:=0;π Fillchar(l.chars,maxlength,sp);π While NOT(Eoln(f) OR Eof(f)) AND (l.length<maxlength) Doπ Beginπ Inc(l.length,1);π System.Read(f,l.chars[l.length]);π End;ππ IF Not(eof(f)) Then System.readln(f);πEnd;ππProcedure Long_Write(Var f : text;var l : stringtype);ππVarπ pos : indexrange;ππBeginπ For pos:=1 To Long_Length(l) DOπ System.Write(f,l.chars[pos]);πEnd;ππProcedure Long_Writeln(Var f : text;var l : stringtype);ππVarπ pos : indexrange;ππBeginπ For pos:=1 To Long_Length(l) DOπ System.Write(f,l.chars[pos]);π System.Write(f,cr,lf);πEnd;ππProcedure Long_Copy(s : stringtype;Var d : stringtype; index,count : indexrange);ππVarπ poss,π posd : indexrange;ππBeginπ d.length:=0;π Fillchar(d.chars,maxlength,sp);ππ posd:=0;π poss:=index;ππ WHILE (posd<count) AND (poss<=maxlength) Doπ Beginπ Inc(d.length,1);π Inc(posd,1);π d.chars[posd]:=s.chars[poss];π Inc(poss,1);π End;πEnd;ππProcedure Long_Concat(Var d : stringtype;s : String);ππVarπ posd,π poss : indexrange;πBeginπ posd:=Long_Length(d);π poss:=0;π While (posd<maxlength) AND (poss<Length(s)) Doπ Beginπ Inc(poss,1);π Inc(posd,1);π d.chars[posd]:=s[poss];π Inc(d.length,1);π End;πEnd;ππππ(*πVarπ inf : text;π s,d : stringtype;ππBeginπ Assign(inf,'LSTRING.PAS');π Reset(inf);π While NOT(eof(inf)) Doπ Beginπ Readln(inf,s);π Copy(s,d,1,4);π Writeln(output,s);π Writeln(output,d);π Concat(d,s);π Writeln(output,d);π End;π*)ππEnd.π 2 05-25-9408:23ALL GUY MCLOUGHLIN Speedy Strings SWAG9405 36 ^& {πDJ>Can anyone please help me speed up the following functions?ππ Aha! A challange! <g>ππDJ>I wouldn't mind using built-in assembly either!ππ You can still achieve a large increase in speed without usingπ assembly code. Here's my stab at rewriting your routines.π (These could be written faster still, but I'll leave that upπ to you.)π}ππ{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}π{$M 4096,0,655360}ππprogram Test_New_Tab_Functions;ππ (***** Remove space-wasting chars from end of line. *)π (* *)π function TrimRight2({input }π st_IN : string) :π {output}π string;π varπ by_Index : byte;π beginπ by_Index := length(st_IN);π while st_IN[by_Index] IN [#0,#9,#32] doπ beginπ dec(by_Index);π dec(st_IN[0])π end;π TrimRight2 := st_INπ end; (* TrimRight2. *)ππ (***** Replace tabs with 8 spaces. *)π (* *)π function DeTab2({input }π st_IN : string) :π {output}π string;π varπ by_Index1,π by_Index2 : byte;π st_Temp : string;π beginπ by_Index2 := 0;π fillchar(st_Temp[1], 255, #32);π for by_Index1 := 1 to length(st_IN) doπ if (st_IN[by_Index1] <> #9) thenπ beginπ inc(by_Index2);π st_Temp[by_Index2] := st_IN[by_Index1]π endπ elseπ by_Index2 := succ(by_Index2 shr 3) shl 3;π st_Temp[0] := chr(by_Index2);π DeTab2 := st_Tempπ end; (* DeTab2. *)ππ (***** Replace spaces with tabs to compress string. *)π (* *)π function EnTab2({input }π st_IN : string) :π {output}π string;π varπ by_Count,π by_IndexIN,π by_IndexOUT : byte;π st_Temp : string;π beginπ by_IndexIN := 0;π by_IndexOUT := 0;π by_Count := 0;π st_Temp[0] := #0;π fillchar(st_Temp[1], length(st_IN), #32);π repeatπ inc(by_IndexIN);π if (st_IN[by_IndexIN] <> #32) thenπ beginπ inc(by_IndexOUT);π st_Temp[by_IndexOUT] := st_IN[by_IndexIN]π endπ elseπ beginπ by_Count := 0;π while ((by_IndexIN + by_Count) < length(st_IN))π AND (st_IN[(by_IndexIN + by_Count)] = #32)π AND (((by_IndexIN + by_Count) mod 8) <> 0) doπ inc(by_Count);ππ if (by_Count > 0) thenπ beginπ if (((by_IndexIN + by_Count) mod 8) = 0) thenπ beginπ inc(by_IndexOUT);π st_Temp[by_IndexOUT] := #9;π inc(by_IndexIN, by_Count)π endπ elseπ beginπ inc(by_IndexOUT, by_Count);π inc(by_IndexIN, pred(by_Count))π endπ endπ elseπ inc(by_IndexOUT)π endπ until (by_IndexIN = length(st_IN));π st_Temp[0] := chr(by_IndexOut);π EnTab2 := st_Tempπ end; (* EnTab2. *)ππvarπ by_Loop : byte;π st_Temp1,π st_Temp2 : string;ππBEGINπ st_Temp1[0] := chr(245);π fillchar(st_Temp1[1], 245, 'A');π st_Temp1 := st_Temp1 + #9#0#32#32#9#9#9#0#32#0;ππ st_Temp2 := TrimRight2(st_Temp1);ππ st_Temp1 := '';π for by_Loop := 1 to 17 doπ st_Temp1 := st_Temp1 + 'ABCDEFG' + #9;ππ st_Temp2 := DeTab2(st_Temp1);ππ st_Temp1 := '';π for by_Loop := 1 to 25 doπ st_Temp1 := st_Temp1 + 'ABCDE ';ππ st_Temp2 := EnTab2(st_Temp1)πEND.ππ Benchmarking my new routines against your old routines on myπ 386DX-40 running Novell DOS 7.0, the results are:ππ Old TrimRight Time = 1.034 msπ New TrimRight Time = 0.126 ms (820 percent faster)ππ Old DeTab Time = 2.514 msπ New DeTab Time = 0.391 ms (640 percent faster)ππ Old EnTab Time = 8.450 msπ New EnTab Time = 1.004 ms (840 percent faster)ππ ...Two things to keep in mind when trying to optimize a routineπ are:π Always try to reduce the number of loops your routineπ has to make.ππ Copy/Move your data as little as possible.ππ 3 05-26-9406:13ALL JEFF FANJOY Complete String Unit SWAG9405 37 ^& UNIT Strings;ππINTERFACEππUSESπ CRT, {Import TextColor,TextBackGround}π DOS; {Import FSplit,PathStr,NameStr,ExtStr,DirStr}ππTYPEπ TDir = (L,R);πππFUNCTION Str2Int(Str: String; (* Converts String to Integer *)π VAR Code: Integer): Integer;πFUNCTION Int2Str(I: Integer): String; (* Converts Integer to String *)πFUNCTION StripSlash(Str: String): String; (* String trailing '\' *)πFUNCTION AddSlash(Str: String): String; (* Add trailing '\' *)πFUNCTION PadStr(Str: String; (* Pad String with characters *)π Ch: Char; (* Character to pad with *)π Num: Byte; (* Number of places to pad to *)π Dir: TDir): String; (* Direction to pad in *)πFUNCTION UpCaseStr(Str: String): String; (* Convert string to uppercase *)πFUNCTION LowCaseStr(Str: String): String; (* Convert string to lowercase *)πFUNCTION NameForm(Str: String): String; (* Convert string to Name format *)πFUNCTION StripExt(Str: String): String; (* Strip Extension from filename *)πFUNCTION AddExt(Str,Ext: String): String; (* Add Extension to filename *)πFUNCTION ExtractFName(Str: String): String; (* Extract Filename *)πFUNCTION ExtractFExt(Str: String): String; (* Extract file extension *)πPROCEDURE Pipe(Str: String); (* Write string allowing for pipe codes *)πππIMPLEMENTATIONπππFUNCTION Str2Int(Str: String;π VAR Code: Integer): Integer;πVAR I: Integer;ππBEGINπ VAL(Str,I,Code);π Str2Int := I;πEND;πππFUNCTION Int2Str(I: Integer): String;πVAR S: String;ππBEGINπ STR(I,S);π Int2Str := S;πEND;πππFUNCTION StripSlash(Str: String): String;ππBEGINπ IF Str[Length(Str)] = '\' THENπ StripSlash := COPY(Str,1,Length(Str)-1);πEND;πππFUNCTION AddSlash(Str: String): String;ππBEGINπ IF Str[Length(Str)] <> '\' THENπ AddSlash := Str + '\';πEND;πππFUNCTION PadStr(Str: String;π Ch: Char;π Num: Byte;π Dir: TDir): String;πVARπ TempStr: String;π B: Byte;ππBEGINπ TempStr := '';π IF Length(Str) < Num THENπ BEGINπ FOR B := Length(Str) TO Num DO TempStr := TempStr + Ch;π CASE Dir OFπ L: PadStr := TempStr + Str;π R: PadStr := Str + TempStr;π END;π ENDπ ELSEπ BEGINπ FOR B := 1 TO Num DO TempStr := TempStr + Str[B];π PadStr := TempStr;π END;πEND;πππFUNCTION UpCaseStr(Str: String): String;πVARπ TempStr: String;π B: Byte;ππBEGINπ TempStr := Str;π FOR B := 1 TO Length(Str) DO TempStr[B] := UpCase(TempStr[B]);π UpCaseStr := TempStr;πEND;πππFUNCTION LowCaseStr(Str: String): String;πVARπ TempStr: String;π B: Byte;ππBEGINπ TempStr := Str;π FOR B := 1 TO Length(Str) DO IF TempStr[B] IN ['A'..'Z'] THENπ TempStr[B] := CHR(ORD(TempStr[B])+32);π LowCaseStr := TempStr;πEND;πππFUNCTION NameForm(Str: String): String;πVARπ TempStr: String;π Pos: Byte;ππBEGINπ TempStr := Str;π TempStr[1] := UpCase(TempStr[1]);π FOR Pos := 2 TO Length(TempStr) DOπ IF TempStr[Pos] = #32 THENπ TempStr[Pos+1] := UpCase(TempStr[Pos+1])π ELSEπ IF TempStr[Pos] IN ['A'..'Z'] THENπ TempStr[Pos] := CHR(ORD(TempStr[Pos])+32);π NameForm := TempStr;πEND;πππFUNCTION StripExt(Str: String): String;πVAR DotPos: Byte;ππBEGINπ DotPos := POS('.',Str);π IF DotPos > 1 THEN StripExt := COPY(Str,1,DotPos-1)π ELSE StripExt := Str;πEND;πππFUNCTION AddExt(Str,Ext: String): String;πVAR DotPos: Byte;ππBEGINπ DotPos := POS('.',Str);π IF (DotPos > 1) AND (DotPos < 10) THEN AddExt := COPY(Str,1,DotPos) + Extπ ELSE IF DotPos = 0 THEN AddExt := Str + '.' + Ext;πEND;πππFUNCTION ExtractFName(Str: String): String;πVARπ Path: PathStr;π Dir: DirStr;π Name: NameStr;π Ext: ExtStr;ππBEGINπ Path := Str;π FSplit(Path,Dir,Name,Ext);π ExtractFName := Name+Ext;πEND;πππFUNCTION ExtractFExt(Str: String): String;πVARπ Path: PathStr;π Dir: DirStr;π Name: NameStr;π Ext: ExtStr;ππBEGINπ Path := Str;π FSplit(Path,Dir,Name,Ext);π ExtractFExt := Ext;πEND;πππPROCEDURE Pipe(Str: String);πVARπ StrPos, Err: Integer;π Col: Byte;ππBEGINπ StrPos := 1;π IF Length(Str) < 1 THEN Exit;π REPEATπ IF (Str[StrPos] = '|') THENπ BEGINπ Val(Copy(Str,StrPos+1,2),Col,Err);π IF (Err = 0) AND (Col IN [0..23]) THENπ IF Col IN [0..15] THEN TextColor(Col)π ELSE TextBackGround(Col-16);π Inc(StrPos,3);π ENDπ ELSEπ BEGINπ Write(Str[StrPos]);π Inc(StrPos);π END;π UNTIL (StrPos > Length(Str));πEND;πππBEGINπEND.π 4 05-26-9406:21ALL KEN HENDERSON Word Strings-64K SWAG9405 185 ^& {$S-,R-,V-,I-,B-,F+}ππ{$IFNDEF Ver40}π {$I OPLUS.INC}π{$ENDIF}ππ{*********************************************************}π{* TPWRDSTR.PAS 1.0 *}π{* Copyright (c) Ken Henderson 1990. *}π{* *}π{* *}π{* All rights reserved. *}π{*********************************************************}ππunit TPWrdStr;π {-Routines to support strings which use a word in the place of Turbo Pascal'sπ byte for holding the length of a string -- theoretically allowing stringsπ as large as 64k.}ππinterfaceππusesπ TpString;ππconstπ MaxWrdStr = 1024; {Maximum length of WrdStr - increase up to 65519}π NotFound = 0; {Returned by the Pos functions if substring not found}ππtypeπ WrdStr = array[-1..MaxWrdStr] of Char;π WrdStrPtr = ^WrdStr;ππfunction WrdStr2Str(var A : WrdStr) : string;π {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}ππprocedure Str2WrdStr(S : string; var A : WrdStr);π {-Convert a Turbo string into an WrdStr}ππfunction LenWrdStr(A : WrdStr) : Word;π {-Return the length of an WrdStr string}ππprocedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);π {-Return a substring of a. Note start=1 for first char in a}ππprocedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);π {-Delete len characters of a, starting at position start}ππprocedure ConcatWrdStr(var A, B, C : WrdStr);π {-Concatenate two WrdStr strings, returning a third}ππprocedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);π {-Concatenate a string to an WrdStr, returning a new WrdStr}ππprocedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);π {-Insert WrdStr obj at position start of a}ππprocedure InsertStr(Obj : string; var A : WrdStr; Start : Word);π {-Insert string obj at position start of a}ππfunction PosStr(Obj : string; var A : WrdStr) : Word;π {-Return the position of the string obj in a, returning NotFound if not found}ππfunction PosWrdStr(var Obja, A : WrdStr) : Word;π {-Return the position of obja in a, returning NotFound if not found}ππfunction WrdStrToHeap(var A : WrdStr) : WrdStrPtr;π {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}ππprocedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);π {-Return an WrdStr from the heap, empty if pointer is nil}ππprocedure DisposeWrdStr(P : WrdStrPtr);π {-Dispose of heap space pointed to by P}ππfunction ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;π {-Read an WrdStr from text file, returning true if successful}ππfunction WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;π {-Write an WrdStr to text file, returning true if successful}ππprocedure WrdStrUpcase(var A, B : WrdStr);π {-Uppercase the WrdStr in a, returning b}ππprocedure WrdStrLocase(var A, B : WrdStr);π {-Lowercase the WrdStr in a, returning b}ππprocedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);π {-Return an WrdStr of length len filled with ch}ππprocedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);π {-Right-pad the WrdStr in a to length len with ch, returning b}ππprocedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);π {-Right-pad the WrdStr in a to length len with blanks, returning b}ππprocedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);π {-Left-pad the WrdStr in a to length len with ch, returning b}ππprocedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);π {-Left-pad the WrdStr in a to length len with blanks, returning b}ππprocedure WrdStrTrimLead(var A, B : WrdStr);π {-Return an WrdStr with leading white space removed}ππprocedure WrdStrTrimTrail(var A, B : WrdStr);π {-Return an WrdStr with trailing white space removed}ππprocedure WrdStrTrim(var A, B : WrdStr);π {-Return an WrdStr with leading and trailing white space removed}ππprocedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);π {-Return an WrdStr centered in an WrdStr of Ch with specified width}ππprocedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);π {-Return an WrdStr centered in an WrdStr of blanks with specified width}ππfunction CompWrdStr(var a1, a2 : WrdStr) : Boolean;π {-Return equivalence of a1 and a2}ππ {==========================================================================}ππimplementationπconstπ Blank : char = #32;ππ function WrdStr2Str(var A : WrdStr) : string;π {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}π varπ S : string;π Len : Word absolute A;π Slen : byte Absolute S;π beginπ if Len > 255 then SLen := 255π else Slen := Len;π Move(A[1], S[1], SLen);π WrdStr2Str := S;π end;ππ procedure Str2WrdStr(S : string; var A : WrdStr);π {-Convert a Turbo string into an WrdStr}π varπ slen : byte absolute S;π alen : word absolute A;π beginπ Move(S[1], A[1], slen);π alen := slen;π end;ππ function LenWrdStr(A : WrdStr) : Word;π {-Return the length of an WrdStr string}π varπ alen : Word absolute A;π beginπ LenWrdStr := alen;π end;ππ procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);π {-Return a substring of a. Note start=1 for first char in a}π varπ alen : Word absolute A;π olen : Word absolute O;π beginπ if Start > alen thenπ Olen := 0π else beginπ {Don't copy more than exists}π if Start+Len > alen thenπ Len := Succ(alen-Start);π Move(A[Start], O[1], Len);π Olen := Len;π end;π end;ππ procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);π {-Delete len characters of a, starting at position start}π varπ alen : Word Absolute A;π mid : Word;π beginπ if Start <= alen then beginπ {Don't do anything if start position exceeds length of string}π mid := Start+Len;π if mid <= alen then beginπ {Move right remainder of string left}π Move(A[mid], A[Start], len);π Dec(alen,len);π end elseπ {Entire end of string deleted}π alen := Pred(Start);π end;π end;ππ procedure ConcatWrdStr(var A, B, C : WrdStr);π {-Concatenate two WrdStr strings, returning a third}π varπ alen : Word absolute A;π blen : Word absolute B;π clen : Word absolute C;π temp : Word;π beginππ {Put a into the result}π Move(A[1], C[1], alen);ππ {Store as much of b as fits into result}π Temp := blen;π if alen+blen > MaxWrdStr thenπ Temp := MaxWrdStr-alen;π Move(B[1], C[Succ(alen)], Temp);ππ {Terminate the result}π clen := alen+blen;π end;ππ procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);π {-Concatenate a string to an WrdStr, returning a new WrdStr}π varπ alen : Word absolute A;π clen : Word absolute C;π slen : Byte absolute S;π beginππ {Put a into the result}π Move(A[1], C[1], alen);ππ {Store as much of s as fits into result}π if alen+slen > MaxWrdStr thenπ slen := MaxWrdStr-alen;π Move(S[1], C[succ(alen)], slen);ππ {Terminate the result}π clen := alen+slen;π end;ππ procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);π {-Insert WrdStr obj at position start of a}π varπ alen : Word absolute A;π olen : Word absolute Obj;π mid, temp : Word;π beginππ if Start > alen thenπ {Concatenate if start exceeds alen}π Start := Succ(alen)ππ else beginπ {Move right side characters right to make space for insert}π mid := Start+olen;π if mid <= MaxWrdStr thenπ {Room for at least some of the right side characters}π if alen+olen <= MaxWrdStr thenπ {Room for all of the right side}π Move(A[Start], A[mid], Succ(alen-Start))π elseπ {Room for part of the right side}π Move(A[Start], A[mid], Succ(MaxWrdStr-mid));π end;ππ {Insert the obj string}π temp := Olen;π if Start+olen > MaxWrdStr thenπ temp := Succ(MaxWrdStr-Start);π Move(Obj[1], A[Start], temp);ππ {Terminate the string}π if alen+olen <= MaxWrdStr thenπ Inc(alen,olen)π elseπ alen := MaxWrdStr;π end;ππ procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);π {-Insert string obj at position start of a}π varπ alen : Word absolute A;π olen : byte absolute Obj;π mid,temp : Word;π beginππ if Start > alen thenπ {Concatenate if start exceeds alen}π Start := succ(alen)ππ else beginπ {Move right side characters right to make space for insert}π mid := Start+olen;π if mid <= MaxWrdStr thenπ {Room for at least some of the right side characters}π if alen+olen <= MaxWrdStr thenπ {Room for all of the right side}π Move(A[Start], A[mid], Succ(alen-Start))π elseπ {Room for part of the right side}π Move(A[Start], A[mid], Succ(MaxWrdStr-mid));π end;ππ {Insert the obj string}π temp := olen;π if Start+olen > MaxWrdStr thenπ temp := Succ(MaxWrdStr-Start);π Move(Obj[1], A[Start], temp);ππ {Terminate the string}π if alen+olen <= MaxWrdStr thenπ Inc(alen,olen)π elseπ alen := MaxWrdStr;π end;ππ {$L TPWrdStr}π function Search(var Buffer; BufLength : Word; var Match; MatLength : Word) : Word;π external;π procedure WrdStrUpcase(var A, B : WrdStr);π {-Upper case WrdStr A, returning it in B}π varπ alen : Word absolute A;π x : Word;π beginπ For x:=1 to alen do A[x]:=UpCase(A[x]);π Move(A,B,alen+2);π end;π procedure WrdStrLocase(var A, B : WrdStr);π {-Lower case WrdStr A, returning it in B}π varπ alen : Word absolute A;π x : Word;π beginπ For x:=1 to alen do A[x]:=LoCase(A[x]);π Move(A,B,alen+2);π end;ππ function CompWrdStr(var a1, a2 : WrdStr) : Boolean;π {-Compare WrdStr's a1 and a2 and return equivalence}π varπ alen1 : Word absolute A1;π alen2 : Word absolute A2;π x : Word;π beginπ CompWrdStr := false;π If (alen1=alen2) then {possibly equal, let's check it out}π beginπ for x:=1 to alen1 do if (A1[x]<>A2[x]) then exit;π CompWrdStr := true; {If we made it to here, they must be equal}π end;π end;ππ function PosStr(Obj : string; var A : WrdStr) : Word;π {-Return the position of the string obj in a, returning NotFound if not found}π varπ alen : Word absolute A;π olen : Byte absolute Obj;π PosFound : Word;π beginπ PosFound := Search(A[1], alen, Obj[1], olen);π If (PosFound = $FFFF) then {Search didn't find it}π PosFound := 0;π PosStr := Succ(PosFound);π end;ππ function PosWrdStr(var Obja, A : WrdStr) : Word;π {-Return the position of obja in a, returning NotFound if not found}π varπ alen : Word absolute A;π olen : Word absolute Obja;π PosFound : Word;π beginπ PosFound := Search(A[1], alen, Obja[1], olen);π If (PosFound = $FFFF) then {Search didn't find it}π PosFound := 0;π PosWrdStr := Succ(PosFound);π end;ππ function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;π {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}π varπ alen : Word;π P : WrdStrPtr;π beginπ alen := LenWrdStr(A)+2;π if MaxAvail >= alen then beginπ GetMem(P, alen);π Move(A, P^, alen);π WrdStrToHeap := P;π end elseπ WrdStrToHeap := nil;π end;ππ procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);π {-Return an WrdStr from the heap, empty if pointer is nil}π varπ alen : Word absolute a;π plen : Word absolute p;π beginπ if P = nil thenπ Alen := 0π elseπ Move(P^, A, Plen+2);π end;ππ procedure DisposeWrdStr(P : WrdStrPtr);π {-Dispose of heap space pointed to by P}π beginπ if P <> nil thenπ FreeMem(P, LenWrdStr(P^)+2);π end;ππ procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);π {-Return an WrdStr of length len filled with ch}π varπ alen : Word absolute A;π beginπ if Len = 0 thenπ Alen := 0π else beginπ if Len > MaxWrdStr thenπ Len := MaxWrdStr;π FillChar(A[1], Len, Ch);π Alen := Len;π end;π end;ππ procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);π {-Right-pad the WrdStr to length len with ch, returning b}π varπ alen : Word Absolute A;π blen : Word Absolute B;π beginπ if alen >= Len thenπ {Return the input string}π Move(A, B, alen+2)π else beginπ if Len > MaxWrdStr thenπ Len := MaxWrdStr;π Move(A[1], B[1], alen);π FillChar(B[succ(alen)], Len-alen, Ch);π Blen := len;π end;π end;ππ procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);π {-Right-pad the WrdStr to length len with blanks, returning b}π beginπ WrdStrPadCh(A, Blank, Len, B);π end;ππ procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);π {-Left-pad the WrdStr in a to length len with ch, returning b}π varπ alen : Word absolute A;π blen : Word absolute B;π beginπ if alen >= Len thenπ {Return the input string}π Move(A, B, alen+2)π else beginπ FillChar(B[1], Len-alen, Ch);π Move(A[1], B[Succ(Len-alen)], alen);π BLen := Len;π end;π end;ππ procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);π {-Left-pad the WrdStr in a to length len with blanks, returning b}π beginπ WrdStrLeftPadCh(A, Blank, Len, B);π end;ππ procedure WrdStrTrimLead(var A, B : WrdStr);π {-Return an WrdStr with leading white space removed}π varπ alen : Word absolute A;π apos : Word;π beginπ apos := 1;π while (apos < alen) and (A[apos] <= Blank) doπ Inc(apos);π Move(A[apos], B[1], Succ(alen-apos));π end;ππ procedure WrdStrTrimTrail(var A, B : WrdStr);π {-Return an WrdStr with trailing white space removed}π varπ alen : Word absolute A;π blen : Word absolute B;π beginπ while (alen > 1) and (A[Pred(alen)] <= Blank) doπ Dec(alen);π Move(A, B, alen+2);π end;ππ procedure WrdStrTrim(var A, B : WrdStr);π {-Return an WrdStr with leading and trailing white space removed}π varπ blen : Word Absolute B;π beginπ WrdStrTrimLead(A, B);π while (blen > 1) and (B[Pred(blen)] <= Blank) doπ Dec(blen);π end;ππ procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);π {-Return an WrdStr centered in an WrdStr of Ch with specified width}π varπ alen : Word absolute A;π blen : Word absolute B;π beginπ if alen >= Width thenπ {Return input}π Move(A, B, alen+2)π else beginπ FillChar(B[1], Width, Ch);π Move(A[1], B[Succ((Width-alen) shr 1)], alen);π Blen := Width;π end;π end;ππ procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);π {-Return an WrdStr centered in an WrdStr of blanks with specified width}π beginπ WrdStrCenterCh(A, Blank, Width, B);π end;ππtypeπ {text buffer}π TextBuffer = array[0..65520] of Byte;ππ {structure of a Turbo File Interface Block}π FIB = recordπ Handle : Word;π Mode : Word;π BufSize : Word;π Private : Word;π BufPos : Word;π BufEnd : Word;π BufPtr : ^TextBuffer;π OpenProc : Pointer;π InOutProc : Pointer;π FlushProc : Pointer;π CloseProc : Pointer;π UserData : array[1..16] of Byte;π Name : array[0..79] of Char;π Buffer : array[0..127] of Char;π end;ππconstπ FMClosed = $D7B0;π FMInput = $D7B1;π FMOutput = $D7B2;π FMInOut = $D7B3;π CR : Char = ^M;ππ function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;π {-Read an WrdStr from text file, returning true if successful}π varπ CrPos : Word;π alen : Word absolute A;π blen : Word;ππ function RefillBuf(var F : Text) : Boolean;π {-Refill buffer}π varπ Ch : Char;π beginπ with FIB(F) do beginπ BufEnd := 0;π BufPos := 0;π Read(F, Ch);π if IoResult <> 0 then beginπ {Couldn't read from file}π RefillBuf := False;π Exit;π end;π {Reset the buffer again}π BufPos := 0;π RefillBuf := True;π end;π end;πππ beginπ with FIB(F) do beginππ {Initialize the WrdStr length and function result}π alen := 0;π ReadLnWrdStr := False;ππ {Make sure file open for input}π if Mode <> FMInput thenπ Exit;ππ {Make sure something is in buffer}π if BufPos >= BufEnd thenπ if not(RefillBuf(F)) thenπ Exit;ππ {Use the Turbo text file buffer to build the WrdStr}π repeatππ {Search for the next carriage return in the file buffer}π CrPos := Search(BufPtr^[BufPos], Succ(BufEnd-BufPos), CR, 1);ππ if CrPos = $FFFF then beginπ {CR not found, save the portion of the buffer seen so far}π blen := BufEnd-BufPos;π if alen+blen > MaxWrdStr thenπ blen := MaxWrdStr-alen;ππ Move(BufPtr^[BufPos], A[alen], blen);π Inc(alen, blen);ππ {See if at end of file}π if eof(F) then beginπ {Force exit with this line}π CrPos := 0;π {Remove trailing ^Z}π while (alen > 1) and (A[Pred(alen)] = ^Z) doπ Dec(alen);π end else if not(RefillBuf(F)) thenπ Exit;ππ end else beginπ {Save up to the CR}π blen := CrPos;π if alen+blen > MaxWrdStr thenπ blen := MaxWrdStr-alen;π Move(BufPtr^[BufPos], A[alen], blen);π Inc(alen, blen);ππ {Inform Turbo we used the characters}π Inc(BufPos, Succ(CrPos));ππ {Skip over following ^J}π if BufPos < BufEnd then beginπ {Next character is within current buffer}π if BufPtr^[BufPos] = Ord(^J) thenπ Inc(BufPos);π end else beginπ {Next character is not within current buffer}π {Refill the buffer}π if not(RefillBuf(F)) thenπ Exit;π if BufPos < BufEnd thenπ if BufPtr^[BufPos] = Ord(^J) thenπ Inc(BufPos);π end;ππ end;ππ until (CrPos <> $FFFF) or (alen > MaxWrdStr);ππ {Return success and terminate the WrdStr}π ReadLnWrdStr := True;ππ end;π end;ππ function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;π {-Write an WrdStr to text file, returning true if successful}π varπ S : string;π alen : Word absolute A;π apos : Word;π slen : Byte absolute S;π beginπ apos := 1;π WriteWrdStr := False;ππ {Write the WrdStr as a series of strings}π while apos < alen do beginπ slen := alen-apos;π if slen > 255 thenπ slen := 255;π Move(A[apos], S[1], slen);π Write(F, S);π if IoResult <> 0 thenπ Exit;π Inc(apos, slen);π end;ππ WriteWrdStr := True;π end;ππend.πππ{ ----------------- XX3402 Code for TPWRDSTR.OBJ ------------------}π{ Cut HERE and save save to a files (TPWRDSTR.XX). From DOS execute:π{ XX3402 D TPWRDSTR.XX to create TPWRDSTR.OBJ }ππ*XX3402-000257-280390--72--85-53814----TPWRDSTR.OBJ--1-OF--1πU+s+13FEJp72IpFG9Y3HHQq66++++3FpQa7j623nQqJhMalZQW+UJaJmQqZjPW+l9X+lW6UIπ+21dk9Bw3+lII3RGF3BIIWt-IoqHW-E+ECaU83gG13FEEoxBHIxC9Y3HHLu6+k-+uImK+U++πO7M4++F1HoF3FNU5+0V0++6-+TCA4E+8JJ-1EJB3I377HE+8H2x1EJB3I377HE-TY+o+++24πIoJ-IYB6++++dcU2+20W+N4UFU+-++-JWykSzAFy1cjTWosAWpM4VR7o7AJq08l88wdq4z8iπRFS3obEAIJRKWwfndZtTKLLgHsj58wDf+nD+G-y9tJr80U+VWU6++5E+π***** END OF BLOCK 1 *****ππ{ ----------------------- CUT HERE ----------------------------------- }ππ{ ------------- ASSEMBLER CODE FOR TPWRDSTR.ASM ------------------- }π{ USE TASM TO COMPILE }π;******************************************************π; TPWRDSTR.ASM 1.0π; WrdStr string manipulationπ; Copyright (c) TurboPower Software 1987.π; Portions copyright (c) Sunny Hill Software 1985, 1986π; and used under license to TurboPower Softwareπ; All rights reserved.π;******************************************************ππ INCLUDE TPCOMMON.ASMππ;****************************************************** CodeππCODE SEGMENT BYTE PUBLICππ ASSUME CS:CODEππ PUBLIC Searchππ EXTRN UpCasePrim : FARπ EXTRN LoCasePrim : FARππUpcase MACRO ;UpCase character in ALπ PUSH BXπ CALL UpCasePrimπ POP BXπ ENDMππLocase MACRO ;LoCase character in ALπ PUSH BXπ CALL LoCasePrimπ POP BXπ ENDMππ;****************************************************** Searchππ; function Search(var Buffer; BufLength : Word;π; var Match; MatLength : Word) : Word; external;π;Search through Buffer for Match.π;BufLength is length of range to search.π;MatLength is length of string to matchπ;Returns number of bytes searched to find St, FFFF if not foundππ;equates for parameters:πMatLength EQU WORD PTR [BP+6]πMatch EQU DWORD PTR [BP+8]πBufLength EQU WORD PTR [BP+0Ch]πBuffer EQU DWORD PTR [BP+0Eh]ππSearch PROC FARππ StackFrameBPπ PUSH DS ;Save DSπ CLD ;Go forwardππ LES DI,Buffer ;ES:DI => Bufferπ MOV BX,DI ;BX = Ofs(Buffer)ππ MOV CX,BufLength ;CX = Length of range to scanπ MOV DX,MatLength ;DX = Length of match stringππ TEST DX,DX ;Length(Match) = 0?π JZ Error ;If so, we're doneππ LDS SI,Match ;DS:SI => Match bufferπ LODSB ;AL = Match[1]; DS:SI => Match[2]π DEC DX ;DX = MatLength-1π SUB CX,DX ;CX = BufLength-(MatLength-1)π JBE Error ;Error if BufLength is lessππ;Search for first character in StπNext: REPNE SCASB ;Search forward for Match[1]π JNE Error ;Done if not foundπ TEST DX,DX ;If Length = 1 (DX = 0) ...π JZ Found ; the "string" was foundππ ;Search for remainder of Stππ PUSH CX ;Save CXπ PUSH DI ;Save DIπ PUSH SI ;Save SIππ MOV CX,DX ;CX = Length(St) - 1π REPE CMPSB ;Does rest of string match?ππ POP SI ;Restore SIπ POP DI ;Restore DIπ POP CX ;Restore CXππ JNE Next ;Try again if no matchππ;Calculate number of bytes searched and return in StπFound: DEC DI ;DX = Offset where foundπ MOV AX,DI ;AX = Offset where foundπ SUB AX,BX ;Subtract starting offsetπ JMP Short Done ;Doneππ;Match was not foundπError: XOR AX,AX ;Returnπ DEC AX ;Return FFFFππDone: POP DS ;Restore DSπ ExitCode 10ππSearch ENDPππCODE ENDSππ ENDπ{ END OF TPWRDSTR.ASM }π{------------------------------- CUT HERE ------------------------- }π 5 05-26-9411:04ALL RICHARD MULLEN Format Strings SWAG9405 43 ^& π(******************************************************************************π RealStr.PAS - Routine which formats a double, real or single number to aπ requested number of significant digits.π Author - Richard Mullen CIS 76566,1325π Date - 7/5/90, Released to public domainπ******************************************************************************)π{$O+}π{$F+}π{$R+} { Range checking on }π{$B-} { Boolean complete evaluation off }π{$S-} { Stack checking off }π{$I-} { I/O checking off }π{$V-} { Relaxed variable checking }π{$N+} { Numeric coprocessor }π{$E+} { Numeric coprocessor emulation }ππUNIT RealStr;ππINTERFACEππfunction Real_To_Str (SigDigits : word; Number : double) : string;ππ { SigDigits should be between 2 and 15 for doubles }π { 2 and 11 for reals }π { 2 and 7 for singles }ππIMPLEMENTATIONππ(*****************************************************************************)ππfunction Real_To_Str (SigDigits : word; Number : double) : string;πvarπ i : integer;π ErrorCode : integer;π E_Value : integer;π E_Position : word;π Exponent : string[4];π SDigits : word;π TempString : string;ππbeginπ(*π if SigDigits > 15 then SigDigits := 15; { 15 for double, 11 for real, }π if SigDigits < 2 then SigDigits := 2; { 7 for single }π*)π str (Number, TempString);π delete (TempString, 3, 1); { Delete decimal point }π E_Position := pos ('E', TempString);π val (copy (TempString, E_Position + 1, 5), E_Value, ErrorCode);π Real_To_Str := '';π if ErrorCode <> 0 then exit; { E_Value = exponent }π delete (TempString, E_Position, 6); { Delete exponent string }π { from TempString }π if SigDigits + 2 < E_Position thenπ begin { Round TempString }π insert ('0', TempString, 2); { Insert 0 for overflow } E_Position := pos ('E', TempString);π if TempString[SigDigits + 3] >='5' then {}π inc (TempString[SigDigits + 2]); {}π for i := SigDigits + 2 downto 2 do {}π if TempString [i] = chr (ord ('9') + 1) then {}π begin {}π TempString [i] := '0'; {}π inc (TempString [i - 1]); {}π end; {}π if TempString[2] = '0' then delete (TempString, 2, 1) { <-- no overflow }π else inc (E_Value); { <-- overflow }π end; {}π { Delete extra precision }π delete (TempString, SigDigits + 2, length (TempString));ππ i := length (TempString); { Remove all trailing }π while (TempString[i] = '0') AND (i > 2) do { zeros, leaving only }π begin { significant digits }π delete (TempString, i, 1); {}π dec (i); {}π end; {}ππ SDigits := length (TempString) - 1; { Number of significant digits }ππ if (E_Value >= SigDigits) OR (SDigits - E_Value - 1 > SigDigits) thenπ begin { Scientific notation }π if SDigits > 1 then insert ('.', TempString, 3); {}π str (E_Value, Exponent); {}π TempString := Tempstring + ' E' + Exponent; {}π end {}π elseπ beginπ if E_Value >= 0 then { Exponent is positive }π begin { |Number|, >= 1, can }π for i := 1 to E_Value - SDigits + 1 do { be displayed with }π TempString := TempString + '0'; { no exponent }π if E_Value < SDigits - 1 then insert ('.', TempString, E_Value + 3);π endπ elseπ begin { Exponent is negative }π for i := 1 to - E_Value - 1 do { |Number|, < 1, can }π insert ('0', TempString, 2); { be displayed with }π insert ('0.', TempString, 2); { no exponent }π end; { Add '0.' to number }π end;ππ Real_To_Str := TempString;πend;ππ(************************ No initialization ******************************)πend. 6 05-26-9411:04ALL SWAG SUPPORT TEAM General String Library SWAG9405 179 ^& UNIT STR_STF;π {**------------------------------------------------**}π {** STRING Library OPERATIONS **}π {** Version 1.2 **}π {** Added Pos_Reverse **}π {** Version 1.1 (sped-ups) **}π {** (delete_duplicate_Chars_in_str) **}π {** Added Int_To_Str_Zero_Fill **}π {**------------------------------------------------**}ππ{$O-,F+}ππINTERFACEπ{**************************************************************}π{* Trim removes leading/trailing blanks. *}π{* *}π{**************************************************************}πFUNCTION TRIM (Str : string) : string;ππFUNCTION TRIM_Leading_Only (Str : string) : string;πFUNCTION TRIM_Trailing_Only (Str : string) : string;πFUNCTION TRIM_Quotes (Str : string) : string;ππ{**************************************************************}π{* Right_Justify adds leading blanks. *}π{* NOTE: does not handle cases when *}π{* Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}π{**************************************************************}πFUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;ππ{***************************************************************}π{* Center_Str centers the characters in the string based *}π{* upon the size/midpoint specified. *}π{***************************************************************}πFUNCTION Center_Str (Str : string; Output_Size : integer) : string;ππ{**************************************************************}π{* Change_Case changes the case of the string to UPPER. *}π{* *}π{**************************************************************}πFUNCTION CHANGE_CASE (Str : string) : string;πFUNCTION Lower_Case (Str : string) : string;ππ{**************************************************************}π{* Int_To_Str returns the number converted into ascii chars. *}π{* *}π{**************************************************************}πFUNCTION Int_To_Str (Num : LongInt) : string;πFUNCTION Int_To_Str_Zero_Fill (Num : LongInt; Fill : byte) : string;πFUNCTION Int_Num_Digits (Num : LongInt) : integer;ππ{**************************************************************}π{* Pos_Reverse returns the last occurance of the string *}π{* just before the specified start pos! *}π{**************************************************************}πFUNCTION Pos_Reverse (Str : string;π Delimiter : string;π Start_At : integer) : integer;ππ{**************************************************************}π{* Find_Char returns the position of the char *}π{* *}π{**************************************************************}πFUNCTION Find_Char (Str : string;π Char_Is : char;π Start_At : integer) : INTEGER;ππ{**************************************************************}π{* Delete_The_Char delete all occurances of the char *}π{* *}π{**************************************************************}πFUNCTION Delete_The_Charπ (Str : string;π Char_Is : char) : string;ππ{**************************************************************}π{* Replace_Str_Into inserts the small string into the *}π{* org_str at the position specified *}π{**************************************************************}πFUNCTION Replace_Str_Into (Org_Str : String;π Small_Str : string;π Start, Stop : integer) : string;ππ{**************************************************************}π{* procedure Get_Word_Around_Position *}π{* returns the word based AROUND the position specified *}π{* Searches for blanks around the start_pos *}π{* looking left then right. *}π{**************************************************************}πfunction Get_Word_Around_Positionπ (Str : string;π Start_Pos : integer;π Leftmost_Char_Boundry : integer;π Rightmost_Char_Boundry : integer;π VAR Found_Left_Pos : integer;π VAR Found_Word_Size : integer) : string;ππ{**************************************************************}π{* returns a string with duplicate chars deleted. *}π{**************************************************************}πfunction Delete_Duplicate_Chars_In_Str (Str : string;π Limit_In_A_Row : byte): string;ππ{**************************************************************}π{* returns a string filled with the character specified *}π{**************************************************************}πfunction Fill_String(Len : Byte; Ch : Char) : String;ππ{**************************************************************}π{* Truncates a string to a specified length *}π{**************************************************************}πfunction Trunc_Str(TString : String; Len : Byte) : String;ππ{**************************************************************}π{* Pads a string to a specified length with a specified character }π{**************************************************************}πfunction Pad_Char(PString : String; Ch : Char; Len : Byte) : String;πππ{**************************************************************}π{* Left-justify a string within a certain width *}π{**************************************************************}πfunction Left_Justify_Str (S : String; Width : Byte) : String;πππ{**************************************************************}π{* Note that "Count" is the number of *WORDS* to fill. *}π{* So e.g. you'd use *}π{* "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);" *}π{* by Neil Rubenking *}π{**************************************************************}πPROCEDURE FillWord (VAR Dest; Count, What : Word);πππ{**************************************************************}π{**************************************************************}π{**************************************************************}πIMPLEMENTATIONππ{**************************************************************************}πfunction Min(N1, N2 : Longint) : Longint;π{ Returns the smaller of two numbers }πbeginπ if N1 <= N2 thenπ Min := N1π elseπ Min := N2;πend; { Min }ππ(*π{**************************************************************************}πfunction Max(N1, N2 : Longint) : Longint;π{ Returns the larger of two numbers }πbeginπ if N1 >= N2 thenπ Max := N1π elseπ Max := N2;πend; { Max }π*)ππ{**************************************************************}π{* returns a string filled with the character specified *}π{**************************************************************}πfunction Fill_String(Len : Byte; Ch : Char) : String;πvarπ S : String;πbeginπ IF (Len > 0) THENπ BEGINπ S[0] := Chr(Len);π FillChar(S[1], Len, Ch);π Fill_String := S;π ENDπ ELSE Fill_String := '';πend; { FillString }ππ{**************************************************************}π{* Truncates a string to a specified length *}π{**************************************************************}πfunction Trunc_Str(TString : String; Len : Byte) : String;πbeginπ if (Length(TString) > Len) thenπ beginπ {Delete(TString, Succ(Len), Length(TString) - Len);}π {Move(TString[Succ(Len)+(LENGTH(TString)-Len)], TString[Succ(Len)],π Succ(Length(TString)) - Succ(Len) - Length(TString) - Len));}π Move(TString[LENGTH(TString)+1], TString[Succ(Len)], 2*Len);π Dec(TString[0], Length(TString) - Len);π end;π Str_Stf.Trunc_Str := TString;πend; { TruncStr }ππ{**************************************************************}π{* Pads a string to a specified length with a specified character }π{**************************************************************}πfunction Pad_Char(PString : String; Ch : Char; Len : Byte) : String;πvarπ CurrLen : Byte;πbeginπ CurrLen := Min(Length(PString), Len);π PString[0] := Chr(Len);π FillChar(PString[Succ(CurrLen)], Len - CurrLen, Ch);π Pad_Char := PString;πend; { PadChar }ππ{**************************************************************}π{* Left-justify a string within a certain width *}π{**************************************************************}πfunction Left_Justify_Str(S : String; Width : Byte) : String;πbeginπ Left_Justify_Str := Str_Stf.Pad_Char(S, ' ', Width);πend; { Left_Justify_Str }ππ{**************************************************************}π{* Trim removes leading/trailing blanks. *}π{* *}π{**************************************************************}πFUNCTION TRIM (Str : string) : string;πVARπ i : integer;πBEGINπ i := 1;π WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))π DO INC(i);ππ IF (i > 1) THENπ BEGINπ {Str := COPY (Str, i, Length(Str));}π Move (Str[i], Str[1], Succ(LENGTH(Str))-i);π DEC (Str[0], pred(i));π END;ππ WHILE (Str[LENGTH(str)] = ' ')π DO DEC (Str[0]);ππ Trim := Str;πEND; {trim}ππ{**************************************************************}π{* Trim_Lead removes leading blanks. *}π{* *}π{**************************************************************}πFUNCTION TRIM_Leading_Only (Str : string) : string;πVARπ i : integer;πBEGINπ i := 1;π WHILE ((i < LENGTH(Str)) and (Str[i] = ' '))π DO INC(i);ππ IF (i > 1) THENπ BEGINπ {Str := COPY (Str, i, Length(Str));}π Move (Str[i], Str[1], Succ(LENGTH(Str))-i);π DEC (Str[0], pred(i));π END;ππ Trim_Leading_Only := Str;πEND; {trim_leading_Only}ππ{***************************************************************}πFUNCTION TRIM_Trailing_Only (Str : string) : string;πBEGINπ WHILE (Str[LENGTH(str)] = ' ')π DO DEC (Str[0]);ππ Trim_Trailing_Only := Str;πEND; {trim}ππ{***************************************************************}π{*------------------------------------------------------*}π{* Trim off any lead/trail quotes! *}π{*------------------------------------------------------*}πFUNCTION TRIM_Quotes (Str : string) : string;πbeginπ IF ((LENGTH(Str) > 0) and (Str[1] = '"')) THENπ BEGINπ Move (Str[2], Str[1], pred(LENGTH(Str)));π DEC (Str[0]);π IF (Str[LENGTH(Str)] = '"')π THEN DEC(Str[0]);π END; {if}πTrim_Quotes := Str;πend; {Trim_Quotes}ππ{***************************************************************}π{* Right_Justify adds leading blanks. *}π{* NOTE: does not handle cases when *}π{* Size_To_Be < ACTUAL NUMBER OF CHARACTERS *}π{***************************************************************}πFUNCTION Right_Justify (Str : string; Size_To_Be : integer) : string;πVARπ Temp_Str : string;πBEGINπ Temp_Str := TRIM (Str); {to assure proper length--and NON-BLANK}π Right_Justify := Str_Stf.Left_Justify_Strπ ('', Size_To_Be - Length(Str)) + Str;ππ{ WHILE ((LENGTH(Temp_Str) > 0) ANDπ ( (Size_To_Be > LENGTH (Temp_Str)) ORπ (Temp_Str[Size_To_Be] = ' ') ) )π DO Temp_Str := ' '+ COPY (Temp_Str, 1, Size_To_Be-1);π Right_Justify := Temp_Str;}ππEND; {right_justify}ππ{***************************************************************}π{* Center_Str centers the characters in the string based *}π{* upon the size/midpoint specified. *}π{***************************************************************}πFUNCTION Center_Str (Str : string; Output_Size : integer) : string;πVARπ Ret_Str : string;π Size : integer;πBEGINπ { blank out returning string}π Ret_Str := Str_Stf.Fill_String(Output_Size, ' ');π {FillChar (Ret_Str, output_size, ' ');π Ret_Str[0] := chr(Output_Size);}ππ Str := TRIM (Str);π Size := LENGTH (Str);π IF (Output_Size <= Size)π THEN Ret_Str := Strπ ELSEπ BEGINπ Insert (Str, Ret_Str, (((Output_Size - Size) div 2)+1));π Ret_Str := COPY (Ret_Str, 1, OutPut_Size);π END;π Center_Str := Ret_Str;πEND; {center_str}ππ{**************************************************************}π{* Change_Case changes the case of the string to UPPER. *}π{* *}π{**************************************************************}πFUNCTION Change_Case (Str : string) : string;πvarπ i : integer;πBEGINπ for i := 1 to LENGTH (Str)π do Str[i] := UpCase(Str[i]);π Change_Case := Str;πEND; {change_case}ππ{**************************************************************}πFUNCTION Lower_Case (Str : string) : string;πvarπ i : integer;πBEGINπ for i := 1 to LENGTH (Str)π do IF ((ORD (Str[i]) >= 65) and (ORD(Str[i]) <= 90))π THEN Str[i] := CHR(ORD(Str[i])+32);π Lower_Case := Str;πEND; {lower_case}ππ{**************************************************************}π{* Int_To_Str returns the number converted into ascii chars. *}π{* *}π{**************************************************************}πFUNCTION Int_To_Str (Num : LongInt) : string;πvarπ Temp_Str : string;πBEGINπ STR(Num, Temp_Str);π Int_To_Str := Temp_Str;πEND; {int_to_str}ππFUNCTION Int_To_Str_Zero_Fill (Num : LongInt; Fill : byte) : string;πvarπ Temp_Str : string;π Len : byte;πBEGINπ STR(Num, Temp_Str);π Len := LENGTH(Temp_Str);π IF (Len < Fill)π THEN Temp_Str := Fill_String(Fill-Len, '0')+Temp_Str;π Int_To_Str_Zero_Fill := Temp_Str;πEND; {int_to_str_zero_fill}ππFUNCTION Int_Num_Digits (Num : LongInt) : integer;πvarπ Tens, Digits : Integer;πBEGINπ IF (Num = 0)π THEN Int_Num_Digits := 1π ELSEπ BEGINπ Tens := 1;π Digits := 1;π WHILE ((Num DIV Tens) <> 0) DOπ BEGINπ INC (Digits);π Tens := Tens * 10;π END; {while}ππ IF (Digits > 1)π THEN DEC (Digits);π Int_Num_Digits := Digits;π END; {if}ππEND; {int_num_digits}ππ{**************************************************************}π{* Pos_Reverse returns the last occurance of the string *}π{* just before the specified start pos! *}π{**************************************************************}πFUNCTION Pos_Reverse (Str : string;π Delimiter : string;π Start_At : integer) : integer;πVARπ Temp_Str : string;π Found_Pos, Found_Pos_0 : integer;πBEGINπ Temp_Str := COPY(Str, 1, Start_At); {dont use move since ?start_at <length?}π Found_Pos_0 := 0;π REPEATπ Found_Pos := POS (Delimiter, Temp_Str);π IF (Found_Pos <> 0) THENπ BEGINπ Found_Pos_0 := Found_Pos_0+Found_Pos;π {Temp_Str := COPY(Temp_Str, Found_Pos+1, LENGTH(Temp_Str));}π Move (Temp_Str[Found_Pos+1], Temp_Str[1], LENGTH(Str)-Found_Pos+2);π DEC (Temp_Str[0], Found_Pos);π END;π UNTIL (Found_Pos = 0);π Pos_Reverse := Found_Pos_0;πEND; {pos_reverse}ππ{**************************************************************}π{* Find_Char returns the position of the char *}π{* *}π{**************************************************************}πFUNCTION Find_Char (Str : string;π Char_Is : char;π Start_At : integer) : INTEGER;πVARπ Loc : integer;πBEGINπ Loc := POS (Char_Is, COPY(Str, Start_At, LENGTH(STR)));π IF (Loc <> 0)π THEN Loc := Loc + Start_At -1;π Find_Char := Loc;πEND; {function Find_Char}ππ{**************************************************************}π{* Delete_The_Char delete all occurances of the char *}π{* *}π{**************************************************************}πFUNCTION Delete_The_Char (Str : string;π Char_Is : char) : string;πVARπ Loc : integer;πBEGINπ Loc := 0;π REPEATπ Loc := POS (Char_Is, Str);π IF (Loc <> 0) THENπ BEGINπ {DELETE (Str, Loc, 1);}π Move(Str[Succ(Loc)], Str[Loc], Length(Str)-Loc);π Dec(Str[0]);π END;π UNTIL (Loc = 0);ππ Delete_The_Char := STR;πEND; {function Delete_The_Char}ππ{**************************************************************}π{* Replace_Str_Into inserts the small string into the *}π{* org_str at the position specified *}π{**************************************************************}πFUNCTION Replace_Str_Into (Org_Str : String;π Small_Str : string;π Start, Stop : integer) : string;πvarπ Temp_Small_Str : string;πbeginπ IF (Start = 0)π THEN Start := 1;ππ IF (LENGTH(Small_Str) >= (Stop-Start+1))π THEN Temp_Small_Str := Small_Strπ ELSE Temp_Small_Str := Small_Str +π Fill_String ( (Stop-Start+1-LENGTH(Small_Str)), ' ');π IF (Start > 1)π THEN Replace_Str_Into := Copy (Org_Str, 1, (Start -1)) +π Copy (Temp_Small_Str, 1, (Stop-Start+1))+π Copy (Org_Str, (Stop+1) , LENGTH(Org_Str))π ELSE Replace_Str_Into := Copy (Temp_Small_Str, 1, (Stop-Start+1)) +π Copy (Org_Str, Stop+1, LENGTH(Org_Str));πend; {Replace_Str_into}ππ{**************************************************************}π{* procedure Get_Word_Around_Position *}π{* returns the word based AROUND the position specified *}π{* Searches for blanks around the start_pos *}π{* looking left then right. *}π{**************************************************************}πfunction Get_Word_Around_Positionπ (Str : string;π Start_Pos : integer;π Leftmost_Char_Boundry : integer;π Rightmost_Char_Boundry : integer;π VAR Found_Left_Pos : integer;π VAR Found_Word_Size : integer) : string;πvarπ adjust : integer;ππbeginπ IF ((Start_Pos <= LENGTH(Str))) THENπ BEGINπ Get_Word_Around_Position := Str[Start_Pos];π Found_Left_Pos := Start_Pos;π Found_Word_Size := 1;π ENDππ ELSE {* Bad Params! *}π BEGINπ Get_Word_Around_Position := ' ';π Found_Left_Pos := 0;π Found_Word_Size := 0;π Exit;π END;ππ if (Str[Start_Pos] <> ' ') thenπ beginπ {************************************************}π {* FIRST: find left-most position *}π {************************************************}π adjust := Start_Pos -1;π while ((adjust >= leftmost_char_boundry) andπ (Str[adjust] <> ' '))π do adjust := adjust - 1;π if ((adjust = leftmost_char_boundry) and (Str[adjust] <> ' '))π then Found_Left_Pos := adjustπ else Found_Left_Pos := adjust +1;ππ {************************************************}π {* find right-most position *}π {************************************************}π adjust := Start_Pos +1;π while ((adjust <= Rightmost_Char_Boundry) andπ (Str[adjust] <> ' '))π do adjust := adjust + 1;ππ if ((adjust = Rightmost_char_boundry) and (Str[adjust] <> ' '))π then Found_Word_Size := adjust - Found_Left_Pos +1π else Found_Word_Size := adjust - Found_Left_Pos;ππ Get_Word_Around_Position := Copy (Str, Found_Left_Pos, Found_Word_Size);ππ end; {if}ππend; {get_word_around_position}ππ{**************************************************************}π{* returns a string with duplicate chars deleted. *}π{**************************************************************}πfunction Delete_Duplicate_Chars_In_Str (Str : string;π Limit_In_A_Row : byte) : string;πvarπ Curr_Pos : integer;π i : integer;π Same_Chars : boolean;πbeginππ IF (Limit_In_A_Row = 1) THEN {* must catch or infinite loop *}π BEGINπ Delete_Duplicate_Chars_In_Str := '';π exit;π END;ππ Curr_Pos := 1;π WHILE ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) DOπ BEGINππ {*---------------------------------------*}π {* Quickly look for at least 2 in a row! *}π {*---------------------------------------*}π WHILE (((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) ANDπ (Str[Curr_Pos] <> Str[Succ(Curr_Pos)]))π DO INC(Curr_Pos);ππ IF ((Curr_Pos+Limit_In_A_Row-1) <= LENGTH(Str)) THENπ BEGINπ i := Curr_Pos+1;π Same_Chars := TRUE;π WHILE ((Same_Chars) and (i <= (Curr_Pos+Limit_In_A_Row-1)))π DO IF (Str[Curr_Pos] <> Str[i])π THEN Same_Chars := FALSEπ ELSE INC(i);ππ IF (Same_Chars) THENπ BEGINπ Move(Str[Curr_Pos+Limit_In_A_Row-1], Str[Curr_Pos],π Length(Str)-(Curr_Pos+Limit_In_A_Row-2));π Dec(Str[0],Pred(Limit_In_A_Row));π ENDπ ELSE Inc(Curr_Pos);π END; {if}π END; {while}ππ Delete_Duplicate_Chars_In_Str := Str;πend; {delete_duplicate_chars_in_str}ππ{*π Note that "Count" is the number of *WORDS* to fill. So e.g. you'dπuse "FillWord(My_Int_Array, SizeOf(My_Int_Array) DIV 2, 1);"π by Neil Rubenking *}π{**************************************************************}πPROCEDURE FillWord(VAR Dest; Count, What : Word); Assembler;π ASMπ LES DI, Dest {ES:DI points to destination}π MOV CX, Count {count in CX}π MOV AX, What {word to fill with in AX}π CLD {forward direction}π REP STOSW {perform the fill}π END; {fillWord}ππEND. {unit str_stf}
